home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / C / Applications / Python 1.3.3 / Python 133 68K / python68K / python68K.rsrc / TEXT_0_Init.txt < prev    next >
Text File  |  1996-06-03  |  15KB  |  526 lines
  1. # init.tcl --
  2. #
  3. # Default system startup file for Tcl-based applications.  Defines
  4. # "unknown" procedure and auto-load facilities.
  5. #
  6. # SCCS: @(#) init.tcl 1.53 96/04/11 08:39:35
  7. #
  8. # Copyright (c) 1991-1993 The Regents of the University of California.
  9. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  10. #
  11. # See the file "license.terms" for information on usage and redistribution
  12. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13. #
  14.  
  15. if {[info commands package] == ""} {
  16.     error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
  17. }
  18. package require -exact Tcl 7.5
  19. if [catch {set auto_path $env(TCLLIBPATH)}] {
  20.     set auto_path ""
  21. }
  22. if {[lsearch -exact $auto_path [info library]] < 0} {
  23.     lappend auto_path [info library]
  24. }
  25. package unknown tclPkgUnknown
  26. if {[info commands exec] == ""} {
  27.     # Some machines, such as the Macintosh, do not have exec 
  28.     set auto_noexec 1
  29. }
  30. set errorCode ""
  31. set errorInfo ""
  32.  
  33. # unknown --
  34. # This procedure is called when a Tcl command is invoked that doesn't
  35. # exist in the interpreter.  It takes the following steps to make the
  36. # command available:
  37. #
  38. #    1. See if the autoload facility can locate the command in a
  39. #       Tcl script file.  If so, load it and execute it.
  40. #    2. If the command was invoked interactively at top-level:
  41. #        (a) see if the command exists as an executable UNIX program.
  42. #        If so, "exec" the command.
  43. #        (b) see if the command requests csh-like history substitution
  44. #        in one of the common forms !!, !<number>, or ^old^new.  If
  45. #        so, emulate csh's history substitution.
  46. #        (c) see if the command is a unique abbreviation for another
  47. #        command.  If so, invoke the command.
  48. #
  49. # Arguments:
  50. # args -    A list whose elements are the words of the original
  51. #        command, including the command name.
  52.  
  53. proc unknown args {
  54.     global auto_noexec auto_noload env unknown_pending tcl_interactive
  55.     global errorCode errorInfo
  56.  
  57.     # Save the values of errorCode and errorInfo variables, since they
  58.     # may get modified if caught errors occur below.  The variables will
  59.     # be restored just before re-executing the missing command.
  60.  
  61.     set savedErrorCode $errorCode
  62.     set savedErrorInfo $errorInfo
  63.     set name [lindex $args 0]
  64.     if ![info exists auto_noload] {
  65.     #
  66.     # Make sure we're not trying to load the same proc twice.
  67.     #
  68.     if [info exists unknown_pending($name)] {
  69.         unset unknown_pending($name)
  70.         if {[array size unknown_pending] == 0} {
  71.         unset unknown_pending
  72.         }
  73.         return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
  74.     }
  75.     set unknown_pending($name) pending;
  76.     set ret [catch {auto_load $name} msg]
  77.     unset unknown_pending($name);
  78.     if {$ret != 0} {
  79.         return -code $ret -errorcode $errorCode \
  80.         "error while autoloading \"$name\": $msg"
  81.     }
  82.     if ![array size unknown_pending] {
  83.         unset unknown_pending
  84.     }
  85.     if $msg {
  86.         set errorCode $savedErrorCode
  87.         set errorInfo $savedErrorInfo
  88.         set code [catch {uplevel $args} msg]
  89.         if {$code ==  1} {
  90.         #
  91.         # Strip the last five lines off the error stack (they're
  92.         # from the "uplevel" command).
  93.         #
  94.  
  95.         set new [split $errorInfo \n]
  96.         set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
  97.         return -code error -errorcode $errorCode \
  98.             -errorinfo $new $msg
  99.         } else {
  100.         return -code $code $msg
  101.         }
  102.     }
  103.     }
  104.     if {([info level] == 1) && ([info script] == "") \
  105.         && [info exists tcl_interactive] && $tcl_interactive} {
  106.     if ![info exists auto_noexec] {
  107.         if [auto_execok $name] {
  108.         set errorCode $savedErrorCode
  109.         set errorInfo $savedErrorInfo
  110.         return [uplevel exec >&@stdout <@stdin $args]
  111.         }
  112.     }
  113.     set errorCode $savedErrorCode
  114.     set errorInfo $savedErrorInfo
  115.     if {$name == "!!"} {
  116.         return [uplevel {history redo}]
  117.     }
  118.     if [regexp {^!(.+)$} $name dummy event] {
  119.         return [uplevel [list history redo $event]]
  120.     }
  121.     if [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] {
  122.         return [uplevel [list history substitute $old $new]]
  123.     }
  124.     set cmds [info commands $name*]
  125.     if {[llength $cmds] == 1} {
  126.         return [uplevel [lreplace $args 0 0 $cmds]]
  127.     }
  128.     if {[llength $cmds] != 0} {
  129.         if {$name == ""} {
  130.         return -code error "empty command name \"\""
  131.         } else {
  132.         return -code error \
  133.             "ambiguous command name \"$name\": [lsort $cmds]"
  134.         }
  135.     }
  136.     }
  137.     return -code error "invalid command name \"$name\""
  138. }
  139.  
  140. # auto_load --
  141. # Checks a collection of library directories to see if a procedure
  142. # is defined in one of them.  If so, it sources the appropriate
  143. # library file to create the procedure.  Returns 1 if it successfully
  144. # loaded the procedure, 0 otherwise.
  145. #
  146. # Arguments: 
  147. # cmd -            Name of the command to find and load.
  148.  
  149. proc auto_load cmd {
  150.     global auto_index auto_oldpath auto_path env errorInfo errorCode
  151.  
  152.     if [info exists auto_index($cmd)] {
  153.     uplevel #0 $auto_index($cmd)
  154.     return [expr {[info commands $cmd] != ""}]
  155.     }
  156.     if ![info exists auto_path] {
  157.     return 0
  158.     }
  159.     if [info exists auto_oldpath] {
  160.     if {$auto_oldpath == $auto_path} {
  161.         return 0
  162.     }
  163.     }
  164.     set auto_oldpath $auto_path
  165.     for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {
  166.     set dir [lindex $auto_path $i]
  167.     set f ""
  168.     if [catch {set f [open [file join $dir tclIndex]]}] {
  169.         continue
  170.     }
  171.     set error [catch {
  172.         set id [gets $f]
  173.         if {$id == "# Tcl autoload index file, version 2.0"} {
  174.         eval [read $f]
  175.         } elseif {$id == "# Tcl autoload index file: each line identifies a Tcl"} {
  176.         while {[gets $f line] >= 0} {
  177.             if {([string index $line 0] == "#")
  178.                 || ([llength $line] != 2)} {
  179.             continue
  180.             }
  181.             set name [lindex $line 0]
  182.             set auto_index($name) \
  183.             "source [file join $dir [lindex $line 1]]"
  184.         }
  185.         } else {
  186.         error "[file join $dir tclIndex] isn't a proper Tcl index file"
  187.         }
  188.     } msg]
  189.     if {$f != ""} {
  190.         close $f
  191.     }
  192.     if $error {
  193.         error $msg $errorInfo $errorCode
  194.     }
  195.     }
  196.     if [info exists auto_index($cmd)] {
  197.     uplevel #0 $auto_index($cmd)
  198.     if {[info commands $cmd] != ""} {
  199.         return 1
  200.     }
  201.     }
  202.     return 0
  203. }
  204.  
  205. if {[string compare $tcl_platform(platform) windows] == 0} {
  206.  
  207. # auto_execok --
  208. #
  209. # Returns 1 if there's an executable in the current path for the
  210. # given name, 0 otherwise.  Builds an associative array auto_execs
  211. # that caches information about previous checks, for speed.
  212. #
  213. # Arguments: 
  214. # name -            Name of a command.
  215.  
  216. # Windows version.
  217. #
  218. # Note that info executable doesn't work under Windows, so we have to
  219. # look for files with .exe, .com, or .bat extensions.  Also, the path
  220. # may be in the Path or PATH environment variables, and path
  221. # components are separated with semicolons, not colons as under Unix.
  222. #
  223. proc auto_execok name {
  224.     global auto_execs env
  225.  
  226.     if [info exists auto_execs($name)] {
  227.     return $auto_execs($name)
  228.     }
  229.     set auto_execs($name) 0
  230.     if {[file pathtype $name] != "relative"} {
  231.     foreach ext {.exe .bat .cmd} {
  232.         if {[file exists ${name}${ext}]
  233.         && ![file isdirectory ${name}${ext}]} {
  234.         set auto_execs($name) 1
  235.         }
  236.     }
  237.     return $auto_execs($name)
  238.     }
  239.     if {! [info exists env(PATH)]} {
  240.     if [info exists env(Path)] {
  241.         set path $env(Path)
  242.     } else {
  243.         return 0
  244.     }
  245.     } else {
  246.     set path $env(PATH)
  247.     }
  248.     foreach dir [split $path {;}] {
  249.     if {$dir == ""} {
  250.         set dir .
  251.     }
  252.     foreach ext {.exe .bat .cmd} {
  253.         set file [file join $dir ${name}${ext}]
  254.         if {[file exists $file] && ![file isdirectory $file]} {
  255.         set auto_execs($name) 1
  256.         return 1
  257.         }
  258.     }
  259.     }
  260.     return 0
  261. }
  262.  
  263. } else {
  264.  
  265. # Unix version.
  266. #
  267. proc auto_execok name {
  268.     global auto_execs env
  269.  
  270.     if [info exists auto_execs($name)] {
  271.     return $auto_execs($name)
  272.     }
  273.     set auto_execs($name) 0
  274.     if {[file pathtype $name] != "relative"} {
  275.     if {[file executable $name] && ![file isdirectory $name]} {
  276.         set auto_execs($name) 1
  277.     }
  278.     return $auto_execs($name)
  279.     }
  280.     foreach dir [split $env(PATH) :] {
  281.     if {$dir == ""} {
  282.         set dir .
  283.     }
  284.     set file [file join $dir $name]
  285.     if {[file executable $file] && ![file isdirectory $file]} {
  286.         set auto_execs($name) 1
  287.         return 1
  288.     }
  289.     }
  290.     return 0
  291. }
  292.  
  293. }
  294. # auto_reset --
  295. # Destroy all cached information for auto-loading and auto-execution,
  296. # so that the information gets recomputed the next time it's needed.
  297. # Also delete any procedures that are listed in the auto-load index
  298. # except those related to auto-loading.
  299. #
  300. # Arguments: 
  301. # None.
  302.  
  303. proc auto_reset {} {
  304.     global auto_execs auto_index auto_oldpath
  305.     foreach p [info procs] {
  306.     if {[info exists auto_index($p)] && ($p != "unknown")
  307.         && ![string match auto_* $p]} {
  308.         rename $p {}
  309.     }
  310.     }
  311.     catch {unset auto_execs}
  312.     catch {unset auto_index}
  313.     catch {unset auto_oldpath}
  314. }
  315.  
  316. # auto_mkindex --
  317. # Regenerate a tclIndex file from Tcl source files.  Takes as argument
  318. # the name of the directory in which the tclIndex file is to be placed,
  319. # followed by any number of glob patterns to use in that directory to
  320. # locate all of the relevant files.
  321. #
  322. # Arguments: 
  323. # dir -            Name of the directory in which to create an index.
  324. # args -        Any number of additional arguments giving the
  325. #            names of files within dir.  If no additional
  326. #            are given auto_mkindex will look for *.tcl.
  327.  
  328. proc auto_mkindex {dir args} {
  329.     global errorCode errorInfo
  330.     set oldDir [pwd]
  331.     cd $dir
  332.     set dir [pwd]
  333.     append index "# Tcl autoload index file, version 2.0\n"
  334.     append index "# This file is generated by the \"auto_mkindex\" command\n"
  335.     append index "# and sourced to set up indexing information for one or\n"
  336.     append index "# more commands.  Typically each line is a command that\n"
  337.     append index "# sets an element in the auto_index array, where the\n"
  338.     append index "# element name is the name of a command and the value is\n"
  339.     append index "# a script that loads the command.\n\n"
  340.     if {$args == ""} {
  341.     set args *.tcl
  342.     }
  343.     foreach file [eval glob $args] {
  344.     set f ""
  345.     set error [catch {
  346.         set f [open $file]
  347.         while {[gets $f line] >= 0} {
  348.         if [regexp {^proc[     ]+([^     ]*)} $line match procName] {
  349.             append index "set [list auto_index($procName)]"
  350.             append index " \[list source \[file join \$dir [list $file]\]\]\n"
  351.         }
  352.         }
  353.         close $f
  354.     } msg]
  355.     if $error {
  356.         set code $errorCode
  357.         set info $errorInfo
  358.         catch {close $f}
  359.         cd $oldDir
  360.         error $msg $info $code
  361.     }
  362.     }
  363.     set f ""
  364.     set error [catch {
  365.     set f [open tclIndex w]
  366.     puts $f $index nonewline
  367.     close $f
  368.     cd $oldDir
  369.     } msg]
  370.     if $error {
  371.     set code $errorCode
  372.     set info $errorInfo
  373.     catch {close $f}
  374.     cd $oldDir
  375.     error $msg $info $code
  376.     }
  377. }
  378.  
  379. # pkg_mkIndex --
  380. # This procedure creates a package index in a given directory.  The
  381. # package index consists of a "pkgIndex.tcl" file whose contents are
  382. # a Tcl script that sets up package information with "package require"
  383. # commands.  The commands describe all of the packages defined by the
  384. # files given as arguments.
  385. #
  386. # Arguments:
  387. # dir -            Name of the directory in which to create the index.
  388. # args -        Any number of additional arguments, each giving
  389. #            a glob pattern that matches the names of one or
  390. #            more shared libraries or Tcl script files in
  391. #            dir.
  392.  
  393. proc pkg_mkIndex {dir args} {
  394.     global errorCode errorInfo
  395.     append index "# Tcl package index file, version 1.0\n"
  396.     append index "# This file is generated by the \"pkg_mkIndex\" command\n"
  397.     append index "# and sourced either when an application starts up or\n"
  398.     append index "# by a \"package unknown\" script.  It invokes the\n"
  399.     append index "# \"package ifneeded\" command to set up package-related\n"
  400.     append index "# information so that packages will be loaded automatically\n"
  401.     append index "# in response to \"package require\" commands.  When this\n"
  402.     append index "# script is sourced, the variable \$dir must contain the\n"
  403.     append index "# full path name of this file's directory.\n"
  404.     set oldDir [pwd]
  405.     cd $dir
  406.     foreach file [eval glob $args] {
  407.     # For each file, figure out what commands and packages it provides.
  408.     # To do this, create a child interpreter, load the file into the
  409.     # interpreter, and get a list of the new commands and packages
  410.     # that are defined.  Define an empty "package unknown" script so
  411.     # that there are no recursive package inclusions.
  412.  
  413.     set c [interp create]
  414.     $c eval [list set file $file]
  415.     if [catch {
  416.         $c eval {
  417.         proc dummy args {}
  418.         package unknown dummy
  419.         set origCmds [info commands]
  420.         set dir ""        ;# in case file is pkgIndex.tcl
  421.         set pkgs ""
  422.         if [catch {load $file}] {
  423.             if [catch {source $file}] {
  424.             puts $errorInfo
  425.             error "can't either load or source $file"
  426.             } else {
  427.             set type source
  428.             }
  429.         } else {
  430.             set type load
  431.         }
  432.         foreach i [info commands] {
  433.             set cmds($i) 1
  434.         }
  435.         foreach i $origCmds {
  436.             catch {unset cmds($i)}
  437.         }
  438.         foreach i [package names] {
  439.             if {([string compare [package provide $i] ""] != 0)
  440.                 && ([string compare $i Tcl] != 0)} {
  441.             lappend pkgs [list $i [package provide $i]]
  442.             }
  443.         }
  444.         }
  445.     } msg] {
  446.         interp delete $c
  447.         error $msg $errorInfo $errorCode
  448.     }
  449.     foreach pkg [$c eval set pkgs] {
  450.         lappend files($pkg) [list $file [$c eval set type] \
  451.             [lsort [$c eval array names cmds]]]
  452.     }
  453.     interp delete $c
  454.     }
  455.     foreach pkg [lsort [array names files]] {
  456.     append index "\npackage ifneeded $pkg\
  457.         \"tclPkgSetup \$dir [lrange $pkg 0 0] [lrange $pkg 1 1]\
  458.         [list $files($pkg)]\""
  459.     }
  460.     set f [open pkgIndex.tcl w]
  461.     puts $f $index
  462.     close $f
  463.     cd $oldDir
  464. }
  465.  
  466. # tclPkgSetup --
  467. # This is a utility procedure use by pkgIndex.tcl files.  It is invoked
  468. # as part of a "package ifneeded" script.  It calls "package provide"
  469. # to indicate that a package is available, then sets entries in the
  470. # auto_index array so that the package's files will be auto-loaded when
  471. # the commands are used.
  472. #
  473. # Arguments:
  474. # dir -            Directory containing all the files for this package.
  475. # pkg -            Name of the package (no version number).
  476. # version -        Version number for the package, such as 2.1.3.
  477. # files -        List of files that constitute the package.  Each
  478. #            element is a sub-list with three elements.  The first
  479. #            is the name of a file relative to $dir, the second is
  480. #            "load" or "source", indicating whether the file is a
  481. #            loadable binary or a script to source, and the third
  482. #            is a list of commands defined by this file.
  483.  
  484. proc tclPkgSetup {dir pkg version files} {
  485.     global auto_index
  486.  
  487.     package provide $pkg $version
  488.     foreach fileInfo $files {
  489.     set f [lindex $fileInfo 0]
  490.     set type [lindex $fileInfo 1]
  491.     foreach cmd [lindex $fileInfo 2] {
  492.         if {$type == "load"} {
  493.         set auto_index($cmd) [list load [file join $dir $f] $pkg]
  494.         } else {
  495.         set auto_index($cmd) [list source [file join $dir $f]]
  496.         } 
  497.     }
  498.     }
  499. }
  500.  
  501. # tclPkgUnknown --
  502. # This procedure provides the default for the "package unknown" function.
  503. # It is invoked when a package that's needed can't be found.  It scans
  504. # the auto_path directories looking for pkgIndex.tcl files and sources any
  505. # such files that are found to setup the package database.
  506. #
  507. # Arguments:
  508. # name -        Name of desired package.  Not used.
  509. # version -        Version of desired package.  Not used.
  510. # exact -        Either "-exact" or omitted.  Not used.
  511.  
  512. proc tclPkgUnknown {name version {exact {}}} {
  513.     global auto_path
  514.  
  515.     if ![info exists auto_path] {
  516.     return
  517.     }
  518.     for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {
  519.     set dir [lindex $auto_path $i]
  520.     set file [file join $dir pkgIndex.tcl]
  521.     if [file readable $file] {
  522.         source $file
  523.     }
  524.     }
  525. }
  526.